perm filename TAK.LSP[E78,JMC] blob sn#396685 filedate 1978-11-22 generic text, type T, neo UTF8

(DEFUN TAK (X Y Z) 
       (COND ((LESSP Y X)
	      (TAK (TAK (SUB1 X) Y Z)
		   (TAK (SUB1 Y) Z X)
		   (TAK (SUB1 Z) X Y)))
	     (T Y))) 

(DEFUN CTAK (X Y Z) 
       (COND ((LESSP Y X)
	      (PLUS 1.
		    (CTAK (TAK (SUB1 X) Y Z)
			  (TAK (SUB1 Y) Z X)
			  (TAK (SUB1 Z) X Y))
		    (CTAK (SUB1 X) Y Z)
		    (CTAK (SUB1 Y) Z X)
		    (CTAK (SUB1 Z) X Y)))
	     (T 0.))) 

(DEFUN RANGE (X Y Z) (DIFFERENCE (MAX X Y Z) (MIN X Y Z))) 

(DEFUN CTAK2 (X Y Z) 
       (COND ((MEMCAR (LIST X Y Z) U) 0.)
	     ((NOT (LESSP Y X))
	      (CAR (CONS 0. (SETQ U (CONS (CONS (LIST X Y Z) Y) U)))))
	     (T (PLUS 1.
		      (CTAK2 (SUB1 X) Y Z)
		      (CTAK2 (SUB1 Y) Z X)
		      (CTAK2 (SUB1 Z) X Y)
		      (CTAK2 (TAK2 (SUB1 X) Y Z)
			     (TAK2 (SUB1 Y) Z X)
			     (TAK2 (SUB1 Z) X Y)))))) 

(DEFUN TAK2 (X Y Z) 
       ((LAMBDA (W) 
	 (COND
	  ((NOT (NULL W)) (CDR W))
	  (T (CDAR (SETQ U
			 (CONS (CONS (LIST X Y Z)
				     (COND ((NOT (LESSP Y X)) Y)
					   (T (TAK2 (TAK2 (SUB1 X)
							  Y
							  Z)
						    (TAK2 (SUB1 Y)
							  Z
							  X)
						    (TAK2 (SUB1 Z)
							  X
							  Y)))))
			       U))))))
	(ASSOC (LIST X Y Z) U))) 

(DEFUN CTAK1 (X Y Z) (CDR (CONS (SETQ U NIL) (CTAK2 X Y Z)))) 

(DEFUN MEMCAR (X U) 
       (AND (NOT (NULL U))
	    (OR (EQUAL X (CAAR U)) (MEMCAR X (CDR U))))) 

(SETQ BASE (SETQ IBASE 10.)) 

(DEFUN DTAK (X Y Z) 
       (COND ((NOT (LESSP Y X)) 0.)
	     (T (ADD1 (MAX (DTAK (TAK (SUB1 X) Y Z)
				 (TAK (SUB1 Y) Z X)
				 (TAK (SUB1 Z) X Y))
			   (DTAK (SUB1 X) Y Z)
			   (DTAK (SUB1 Y) Z X)
			   (DTAK (SUB1 Z) X Y)))))) 

(DEFUN NTAK (X Y Z) (VTAK (LIST X Y Z))) 

(DEFUN VTAK (U) 
       (COND ((NUMBERP U) U)
	     ((NULL (CDR U)) (SUB1 (VTAK (CAR U))))
	     (T ((LAMBDA (X Y) 
			 (COND ((NOT (LESSP Y X)) Y)
			       (T (VTAK (LIST (LIST (SUB1 X)
						    Y
						    (CADDR U))
					      (LIST (SUB1 Y)
						    (CADDR U)
						    X)
					      (LIST (LIST (CADDR U))
						    X
						    Y))))))
		 (VTAK (CAR U))
		 (VTAK (CADR U)))))) 

(DEFUN CVTAK (U) 
       (COND ((NUMBERP U) 0.)
	     ((NULL (CDR U)) (CVTAK (CAR U)))
	     (T ((LAMBDA (X Y M N) 
		  (COND ((NOT (LESSP Y X)) (PLUS 1. M N))
			(T (PLUS 1.
				 M
				 N
				 (CVTAK (LIST (LIST (SUB1 X)
						    Y
						    (CADDR U))
					      (LIST (SUB1 Y)
						    (CADDR U)
						    X)
					      (LIST (LIST (CADDR U))
						    X
						    Y)))))))
		 (VTAK (CAR U))
		 (VTAK (CADR U))
		 (CVTAK (CAR U))
		 (CVTAK (CADR U)))))) 

(DEFUN VEVAL (E) 
       (COND ((ATOM E) E)
	     ((EQ (CAR E) 'SUB1) (SUB1 (VEVAL (CADR E))))
	     ((EQ (CAR E) 'IF)
	      (COND ((VEVAL (CADR E)) (VEVAL (CADDR E)))
		    (T (VEVAL (CADDDR E)))))
	     ((EQ (CAR E) 'LESSEQ)
	      (NOT (LESSP (VEVAL (CADDR E)) (VEVAL (CADR E)))))
	     ((ATOM (CAR E))
	      (VEVAL (CONS (GET (CAR E) 'EXPR) (CDR E))))
	     ((EQ (CAAR E) 'LAMBDA)
	      (VEVAL (SUBLIS (PRUP (CADAR E) (CDR E)) (CADDAR E)))))) 

(DEFUN PRUP (U V) 
       (COND ((NULL U) NIL)
	     (T (CONS (CONS (CAR U) (CAR V))
		      (PRUP (CDR U) (CDR V)))))) 

(DEFUN TTAK (X Y Z) 
       (IF (LESSEQ X Y)
	   Y
	   (TTAK (TTAK (SUB1 X) Y Z)
		 (TTAK (SUB1 Y) Z X)
		 (TTAK (SUB1 Z) X Y)))) 

(DEFUN DTAK00 (M N) 
       (COND ((NOT (LESSP 0. M)) 0.)
	     ((LESSP 1. N)
	      (PLUS M (QUOTIENT (TIMES N (SUB1 N)) 2.) -1.))
	     ((LESSP -1. N) M)
	     ((EQUAL N -1.)
	      (PLUS (QUOTIENT (TIMES (ADD1 M) (PLUS M 2.)) 2.) -1.))
	     (T (PLUS (QUOTIENT (TIMES (DIFFERENCE M N)
				       (ADD1 (DIFFERENCE M N)))
				2.)
		      (MINUS M)
		      -1.)))) 

(DEFUN TAK0 (X Y Z) 
       (COND ((NOT (LESSP Y X)) Y) ((NOT (LESSP Z Y)) Z) (T X))) 


(DEFUN TAK4 (X Y Z) 
       (COND ((NOT (LESSP Y X)) Y)
	     (T (TAK4 (TAK4 (DIFFERENCE X 4) Y Z)
		      (TAK4 (DIFFERENCE Y 4) Z X)
		      (tak4 (DIFFERENCE Z 4) X Y)))))